Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue41/Patterns/HVSingleton.PAS

Pascal/Delphi Source File | 1998-11-18 | 5.3 KB | 183 lines

unit HVSingleton;

interface

uses
  SysUtils;

type
  ESingleton = class(Exception);

  TInvalidateDestroy = class(TObject)
  protected
    class procedure SingletonError;
  public
    destructor Destroy; override;
  end;

  TSingletonOpaqueInfo = record end;
  TSingletonHandle = ^TSingletonOpaqueInfo;
  TSingleton = class;
  TSingletonClass = class of TSingleton;
  TSingleton = class(TInvalidateDestroy)
  private
    class procedure Startup;
    class procedure Shutdown;
  protected
    // Allow descendents register themselves
    class function RegisterSingletonClass(aSingletonClass: TSingletonClass): TSingletonHandle;
    // Allow descendents to set a new class for the instance:
    class procedure OverrideSingletonClass(BaseSingletonClass, NewSingletonClass: TSingletonClass);
    // Interface for descendents to get their instance pointer
    class function InstanceOf(Handle: TSingletonHandle): TSingleton;
    // Actual constructor and destructor that will be used:
    constructor SingletonCreate; virtual;
    destructor SingletonDestroy; virtual;
  public
    // Not for use - for obstruction only:
    class procedure Create;
    class procedure Free(Dummy: integer);
{$IFNDEF VER120} {$WARNINGS OFF} {$ENDIF}
    // This generates a warning in D3. D4 has the reintroduce keyword to solve this
    class procedure Destroy(Dummy: integer); {$IFDEF VER120} reintroduce; {$ENDIF}
  end;
{$IFNDEF VER120} {$WARNINGS ON} {$ENDIF}

implementation

uses
  Classes;

{ TInvalidateDestroy }

class procedure TInvalidateDestroy.SingletonError;
// Raise an exception in case of illegal use
begin
  raise ESingleton.CreateFmt('Illegal use of %s singleton instance!', [ClassName]);
end;

destructor TInvalidateDestroy.Destroy;
// Protected against use of default destructor
begin
  SingletonError;
end;

{ TSingleton }

var
  SingletonInstances : TList; { of TSingletons       }
  SingletonClasses   : TList; { of TSingletonClasses }

class procedure TSingleton.Startup;
begin
  SingletonInstances := TList.Create;
  SingletonClasses   := TList.Create;
end;

class procedure TSingleton.Shutdown;
// Time to close down the show
var
  SingletonInstance: TSingleton;
  i : integer;
begin
  // Free any singleton instances
  for i := SingletonInstances.Count-1 downto 0 do
  begin
    SingletonInstance := TSingleton(SingletonInstances.List^[i]);
    if Assigned(SingletonInstance) then
      SingletonInstance.SingletonDestroy;
  end;
  // Free the lists
  SingletonInstances.Free; SingletonInstances := nil;
  SingletonClasses  .Free; SingletonClasses   := nil;
end;

class function TSingleton.RegisterSingletonClass(aSingletonClass: TSingletonClass): TSingletonHandle;
// Register a new Singleton class and allocate space for the instance pointer
var
  Index: integer;
begin
  Assert(Assigned(aSingletonClass));
  Assert(SingletonClasses.IndexOf(Pointer(aSingletonClass)) < 0);
  SingletonClasses.Add(Pointer(aSingletonClass));
  // Return the index +1 of the instace pointer as a handle
  Index := SingletonInstances.Add(nil);
  Result := TSingletonHandle(Index+1);
  Assert(SingletonClasses.Count = SingletonInstances.Count);
end;

class procedure TSingleton.OverrideSingletonClass(BaseSingletonClass, NewSingletonClass: TSingletonClass);
// Allow change of instance class
var
  ThisClass: TSingletonClass;
  i : integer;
begin
  Assert(Assigned(BaseSingletonClass));
  Assert(Assigned(NewSingletonClass));
  Assert(BaseSingletonClass <> TSingleton);
  Assert(NewSingletonClass.InheritsFrom(BaseSingletonClass));
  for i := 0 to SingletonClasses.Count-1 do
  begin
    ThisClass := TSingletonClass(SingletonClasses.List^[i]);
    if ThisClass.InheritsFrom(BaseSingletonClass) and
       (SingletonInstances.List^[i] = nil)        then
    begin
      SingletonClasses.List^[i] := Pointer(NewSingletonClass);
      Exit;
    end;
  end;
  // If we get, here the base class was not found or
  // an instance had already been created
  SingletonError;
end;

class function TSingleton.InstanceOf(Handle: TSingletonHandle): TSingleton;
// Single Instance function - create when first needed
var
  Index: Integer;
begin
  // Convert the handle back to an index - subtract 1
  Index := Integer(Handle) - 1;
  Assert((Index >= 0) and (Index <= SingletonInstances.Count-1));
  Assert(Assigned(SingletonClasses.List^[Index]));
  if not Assigned(SingletonInstances.List^[Index]) then
    SingletonInstances.List^[Index] := TSingletonClass(SingletonClasses.List^[Index]).SingletonCreate;
  Result := SingletonInstances.List^[Index];
end;

constructor TSingleton.SingletonCreate;
// Protected constructor
begin
  inherited Create;
end;

destructor TSingleton.SingletonDestroy;
// Protected destructor
begin
  // We cannot call inherited Destroy; here!
  // It would raise an ESingleton exception
end;

// Protected against use of default constructor
class procedure TSingleton.Create;
begin
  SingletonError;
end;

// Protected against use of Free
class procedure TSingleton.Free(Dummy: integer);
begin
  SingletonError;
end;

// Protected against use of default destructor
class procedure TSingleton.Destroy(Dummy: integer);
begin
  SingletonError;
end;

initialization
  TSingleton.Startup;
finalization
  TSingleton.Shutdown;
end.